home *** CD-ROM | disk | FTP | other *** search
/ Acorn User: China / Acorn User China CD-ROM (UK) (Disc B) / Acorn User China CD-ROM (UK) (Disc B).bin / STUTTGART / EDITORS / LEDIT / !lEdit_l_text < prev    next >
Encoding:
Text File  |  1995-01-19  |  15.1 KB  |  452 lines
  1. ;;;                  ***  lEdit - Lisp Editor  ***
  2. ;;;                       (c) 1995 Urs Bisang
  3. ;;;                           Version 0.1  
  4. ;;;
  5. ;;;   dieses file enthaelt high-level support routinen 
  6. ;;;         fuer das txt modul von riscoslib
  7. ;;;
  8.  
  9.  
  10. ;;; *** globale variablen ***
  11.  
  12. ;; liste aller aktiver text buffers 
  13. (define *text-bufferlist* '())
  14.  
  15. ;; default name um eine selection abzuspeichern
  16. (define *text-selection-name* "Selection")
  17.  
  18. ;; das letzte von find benutzte suchstring
  19. (define *text-previous-searchstring* "")
  20.  
  21. ;; flag das anzeigt ob find casesensitiv suchen soll
  22. (define *text-casesensitiv-find* #f)
  23.       
  24. ;; bringe den cursor an den start des text buffers
  25. (define (text-cursor-home text) (txt-setdot text 0))
  26.  
  27. ;; bringe den cursor ans ende des text buffers
  28. (define (text-cursor-end text) 
  29.   (txt-setdot text (txt-size text))) 
  30.  
  31.  
  32. ;; bewege den cursor um eine bildschirmhoehe nach unten
  33. (define (text-cursor-pagedown text)
  34.   (txt-movevertical text (txt-visiblelinecount text) 1)) 
  35.  
  36. ;; bewege den cursor um eine bildschirmhoehe nach oben
  37. (define (text-cursor-pageup text)
  38.   (txt-movevertical text (- (txt-visiblelinecount text)) 1))
  39.  
  40. ;; loesche n zeichen an der stelle i im textbuffer
  41. (define (text-deleteat text i n)
  42.   ;; falls der dot nach der selection ist, adjust dot. 
  43.   ;; falls der dot innerhalb der selection ist,
  44.   ;; setze dot an den anfang der selection   
  45.   (if (> (txt-dot text) i)
  46.       (if (< (txt-dot text) (+ i n))
  47.           (txt-setdot text i)
  48.           (txt-movedot text (- n))))
  49.   (let ((old-dot (txt-dot text)))
  50.     (txt-setdot text i)
  51.     (txt-delete text n)
  52.     (txt-setdot text old-dot)))
  53.  
  54.  
  55. ;; loesche selektierten text aus dem textbuffer
  56. (define (text-delete-selection)
  57.   (if (txtscrap-selectowner)
  58.       (let ((text  (txtscrap-selectowner))
  59.             (start (txt-selectstart text))
  60.             (end   (txt-selectend text)))   
  61.         (text-deleteat text start (- end start))
  62.         (text-clear-selection))))
  63.  
  64.  
  65. ;; loesche eine selektion   
  66. (define (text-clear-selection)
  67.   (if (txtscrap-selectowner)
  68.       (txtscrap-setselect (txtscrap-selectowner) 0 0)))                   
  69.  
  70.  
  71. ;; kopiere eine selection
  72. (define (text-copy-selection text1)
  73.   (if (txtscrap-selectowner)
  74.       (let ((text2  (txtscrap-selectowner))
  75.             (selection (txt-getselection text2)))
  76.         (txt-insertstring* text1 selection))))
  77.  
  78.  
  79. ;; verschiebe eine selection
  80. (define (text-move-selection text1)
  81.   (if (txtscrap-selectowner)
  82.       (let ((text2  (txtscrap-selectowner))
  83.             (n (- (txt-selectend text2)
  84.                   (txt-selectstart text2)))
  85.             (selection (txt-getselection text2)))
  86.         (text-delete-selection)
  87.         (txt-insertstring text1 selection)
  88.         (txtscrap-setselect text1 
  89.                             (txt-dot text1)
  90.                             (+ (txt-dot text1) n))
  91.         (txt-movedot text1 n))))
  92.  
  93.  
  94. ;; ist ein text buffer veraendert seit der letzten speicherung ? 
  95. (define (text-buffer-updated? text)
  96.   (= (bit-and (txt-charoptions text) 4) 4))
  97.  
  98.    
  99. ;; zeige aenderungen im text buffer nicht sofort an
  100. (define (text-dont-update text)
  101.   (txt-setcharoptions text 1 0))
  102.  
  103.  
  104. ;; zeige aenderungen im text buffer sofort an
  105. (define (text-update text)
  106.   (txt-setcharoptions text 1 1))
  107.  
  108.  
  109. ;; update den titel eines editor windows
  110. (define (text-update-title text)
  111.   (txt-settitle text
  112.     (string-concat 
  113.       (if (getp text 'filename)
  114.           (getp text 'filename)
  115.           *lisp-untitled-name*)
  116.       (if (text-buffer-updated? text)
  117.           " *" 
  118.           "")
  119.       (if (> (txtwin-number text) 1) 
  120.           (string-concat " " (txtwin-number text)) 
  121.           "")
  122.       " (" (getp text 'modename) ")")))
  123.  
  124.  
  125. ;; erzeuge einen neuen view eines schon bestehenden windows
  126. (define (text-new-view text)
  127.   (let ((text1 (gensym)))
  128.    (set-eval! text1 text)
  129.    (txtwin-new text)      
  130.    ;; bug in riscos lib???
  131.    ;; window title und menu handler muessen hier neu gesetzt werden
  132.    ;; damit es funktioniert !!       
  133.    (text-update-title text)
  134.    (event-attachmenumaker (txt-syshandle text)         
  135.                            lisp-ledit-menu-maker&handler
  136.                            text1)))
  137.   
  138.  
  139. ;; schliesse ein fenster eines text buffers und speichere 
  140. ;; den buffer (falls noetig) wenn das letzte fenster des 
  141. ;; buffers geschlossen wird
  142. (define (text-close-window text)
  143.   (if (> (txtwin-number text) 1)
  144.       (begin (txtwin-dispose text)
  145.              (text-update-title text))
  146.       (text-remove-buffer text)))
  147.                     
  148.  
  149. ;; entferne einen buffer und schliesse alle zum buffer gehoerenden
  150. ;; fenster. frage ob der buffer gespeichert werden soll, falls er
  151. ;; veraendert wurde
  152. (define (text-remove-buffer text)
  153.   (if (text-buffer-updated? text)
  154.       (if (text-query-save text)
  155.           (text-kill-buffer text))
  156.       (text-kill-buffer text)))
  157.  
  158.                                   
  159. ;; fragt mit einer dialogbox ob ein buffer gesaved werden soll
  160. ;; und speichert den buffer falls es zutrifft
  161. (define (text-query-save text)               
  162.   (let ((field (dbox-popup "close" "This file has been modified"))) 
  163.     (cond
  164.       ((= field 0) (text-save-buffer text))        ; save
  165.       ((= field 2) #t)                             ; discard
  166.       ((= field 3) #f)                             ; cancel
  167.       (else #f))))
  168.  
  169.  
  170. ;; entfernt einen buffer aus dem speicher und der buffer-liste
  171. (define (text-kill-buffer text)
  172.   (set! *text-bufferlist* (list-remove *text-bufferlist* text))
  173.   ;; bug in riscoslib? text selection wird nicht geloescht,
  174.   ;; wenn buffer entfernt wird !!! muss explizit geloescht werden!
  175.   (if (equal? text (txtscrap-selectowner))
  176.       (text-clear-selection))
  177.   (txt-dispose text))
  178.  
  179. ;; gib die anzahl modifizierter text buffer zurueck oder #f
  180. (define (text-modified-buffers)
  181.    (let ((n 0) (l *text-bufferlist*))
  182.      (while l
  183.        (if (text-buffer-updated? (car l))
  184.            (inc! n)) 
  185.        (set! l (cdr l)))
  186.      (if (= n 0) #f n)))
  187.  
  188.  
  189. ;; speichere einen text buffer
  190. (define (text-save-buffer text)
  191.   (if (getp text 'filename)
  192.       (text-save text)
  193.       (text-saveas text)))
  194.       
  195.  
  196. ;; speichere text buffer mittels dragging
  197. (define (text-saveas text)
  198.    (let ((filename (getp text 'filename)))
  199.      (cond (filename (txt-saveas text filename 0 (txt-size text) #t))
  200.            (else (set! filename 
  201.                    (txt-saveas text (getp text 'defaultname)
  202.                                     0 (txt-size text) #t))
  203.                  (cond (filename (setp! text 'filename filename)
  204.                                  (text-update-title text)
  205.                                  filename)
  206.                        (else #f))))))
  207.  
  208.  
  209. ;; speichere current selection mittels dragging
  210. (define (text-save-selection text1)
  211.   (let ((text (txtscrap-selectowner)))
  212.     (if text
  213.         (txt-saveas text                  
  214.                     *text-selection-name*
  215.                     (txt-selectstart text) 
  216.                     (txt-selectend text) 
  217.                     #t))))
  218.  
  219. ;; printe current selection
  220. (define (text-print-selection text1)
  221.   (let ((text (txtscrap-selectowner)))
  222.     (if text
  223.         (if (not (txt-print text 
  224.                             (txt-selectstart text)
  225.                             (txt-selectend text)
  226.                             #t))
  227.             (werr 0 "can't print - printer application not found"))))) 
  228.            
  229.  
  230. ;; speichere text buffer bei schon bekanntem namen 
  231. (define (text-save text)
  232.   (let ((filename (getp text 'filename)))
  233.     (if filename
  234.         (begin
  235.           (txt-save text filename 0 (txt-size text) #t)
  236.           (text-update-title text) 
  237.           #t)
  238.         #f)))
  239.  
  240.  
  241. ;; printe den inhalt des text buffers
  242. (define (text-print text)
  243.   (if (not (txt-print text 0 (txt-size text) #t))
  244.       (werr 0 "can't print - printer application not found")))
  245.  
  246.  
  247. ;; fuege ein in ein editor window gedraggtes file an der cursor 
  248. ;; position ein
  249. (define (text-insert-dragged-file text)
  250.   (let ((filename (car (xferrecv-checkinsert))))
  251.     (cond ((txt-load text filename (txt-dot text) #t)
  252.            (txt-setcharoptions text 4 4)   ; text is updated
  253.            (text-update-title text)))
  254.     (xferrecv-insertfileok)))   
  255.  
  256.  
  257. ;; lade ein in auf das baricon gedraggtes file und zeige
  258. ;; es in einem neuen window an
  259. ;; im moment gibt es nur einen mode und einen fileloader
  260. (define (text-load-dragged-file)
  261.   (let ((filename (car (xferrecv-checkinsert))))
  262.     (lisp-load-file filename)
  263.     (xferrecv-insertfileok))) 
  264.  
  265.  
  266. ;; lade ein file aufgrund eines dataopen events und zeige
  267. ;; es in einem neuen window an
  268. ;; im moment gibt es nur einen mode und einen fileloader
  269. (define (text-dataopen-proc) 
  270.   (let ((res (xferrecv-checkinsert))
  271.         (filename (first res))
  272.         (filetype (second res)))
  273.     (cond ((= filetype #xfff) ; nur textfiles werden geladen
  274.            (lisp-load-file filename)
  275.            (xferrecv-insertfileok))))) ; acknowledge dataopen
  276.  
  277.  
  278.  
  279. ;; pruefe ob das file schon geladen ist (multiple-loaded) und 
  280. ;; zeige eine dialog-box an, falls das file schon geladen wurde
  281. (define (text-file-loaded? filename) 
  282.   (let ((l *text-bufferlist*) (res #f))
  283.     (while l
  284.       (if (equal? (getp (car l) 'filename) filename)
  285.           (let ((field (dbox-popup "MultiEdit" 
  286.                          (string-concat "'" filename 
  287.                            "' is already loaded!")))) 
  288.             (cond
  289.               ((= field 0) (set! res #f))        ; trotzdem editieren
  290.               ((= field 2) (set! res #t))        ; cancel                    
  291.               (else (set! res #t)))              ; forget it
  292.             (set! l nil)))     ; exit loop
  293.       (set! l (cdr l))) 
  294.     res))        
  295.  
  296.  
  297.         
  298. ;; zeige die goto dialog box an und springe zur eingegebenen zeile
  299. (define (text-goto-dbox text)
  300.   (let ((d (dbox-new "goto")))
  301.     (dbox-setnumeric d 2 (txt-linenumber text))
  302.     (dbox-setnumeric d 3 (txt-dot text))
  303.     (dbox-show d)
  304.     (if (>= (dbox-fillin d) 0)
  305.         (txt-movevertical text (- (dbox-getnumeric d 4)
  306.                                   (txt-linenumber text)) 0))
  307.     (dbox-dispose d))) 
  308.  
  309.  
  310. ;; zeige die replace dialog box an und ersetze text
  311. (define (text-replace-dbox text)
  312.   (let ((d (dbox-new "replace"))
  313.         (field 0)
  314.         (pending #t))  
  315.     ;; setze felder auf default werte
  316.     (if *text-casesensitiv-find*
  317.         (dbox-setnumeric d 7 1)
  318.         (dbox-setnumeric d 7 0))
  319.     (dbox-setfield d 8 "Please enter search string")
  320.     (dbox-show d)
  321.     (while pending
  322.            (set! field (dbox-fillin d))
  323.            ;; case sensitives suchen ?
  324.            (if (\= (dbox-getnumeric d 7) 0)
  325.                (set! *text-casesensitiv-find* #t)
  326.                (set! *text-casesensitiv-find* #f))
  327.            (cond
  328.              ;; Go, suche vom anfang des buffers an
  329.              ((= field 0) 
  330.               (txt-setdot text 0)
  331.               (text-find-next text d))                 
  332.              ;; Previous
  333.              ((= field 1) (text-find-previous text d)) 
  334.              ;; Search String (no action)
  335.              ((= field 2) #t)          
  336.              ;; Replace
  337.              ((= field 5) (text-do-replace text d))
  338.              ;; Replace All
  339.              ((= field 6) (text-do-replace-all text d))
  340.              ;; Replace String & Next
  341.              ((or (= field 3) (= field 4)) 
  342.               (text-find-next text d))
  343.              (else (set! pending #f))))
  344.     (dbox-dispose d)))
  345.  
  346. ;; ersetze gefundenes string im text buffer
  347. (define (text-do-replace text d)
  348.   (cond ((txt-selectset text)
  349.          (txt-setdot text (txt-selectstart text))      
  350.          (txt-delete text (- (txt-selectend text)
  351.                              (txt-selectstart text)))
  352.          (txt-insertstring* text (dbox-getfield d 3 60))
  353.          (text-find-next text d))))
  354.    
  355.  
  356. ;; ersetze alle passenden strings bis zum ende des text buffers
  357. (define (text-do-replace-all text d)
  358.   (let ((count 0)
  359.         (old-pos (txt-dot text))
  360.         (found #f)
  361.         (s (dbox-getfield d 2 60)))
  362.     (cond ((> (length s) 0)
  363.            (dbox-setfield d 8 "replacing ...")
  364.            (text-dont-update text)
  365.            (set! *text-previous-searchstring* s)
  366.            (while (set! found (txt-findforward text s
  367.                                                *text-casesensitiv-find*))
  368.                   (inc! count)
  369.                   (text-do-replace text d))
  370.            (dbox-setfield d 8 (string-concat count " replaced"))
  371.            (txt-setdot text old-pos)
  372.            (text-update text)))))
  373.  
  374. ;; zeige die find dialog box an und suche den text
  375. (define (text-find-dbox text)
  376.   (let ((d (dbox-new "find"))
  377.         (field 0)
  378.         (pending #t))  
  379.     ;; setze felder auf default werte
  380.     (if *text-casesensitiv-find*
  381.         (dbox-setnumeric d 6 1)
  382.         (dbox-setnumeric d 6 0))
  383.     (dbox-setfield d 8 "Please enter search string")
  384.     (dbox-show d)
  385.     (while pending
  386.            (set! field (dbox-fillin d))
  387.            ;; case sensitives suchen ?
  388.            (if (\= (dbox-getnumeric d 6) 0)
  389.                (set! *text-casesensitiv-find* #t)
  390.                (set! *text-casesensitiv-find* #f))
  391.            (cond
  392.              ;; Go, suche vom anfang des buffers an
  393.              ((= field 0) 
  394.               (txt-setdot text 0)
  395.               (text-find-next text d))                 
  396.              ;; Previous
  397.              ((= field 1) (text-find-previous text d)) 
  398.              ;; Count   
  399.              ((= field 4) (text-find-count text d))
  400.              ;; Search String & Next
  401.              ((or (= field 2) (= field 3)) 
  402.               (text-find-next text d))
  403.              (else (set! pending #f))))
  404.     (dbox-dispose d)))
  405.  
  406.  
  407. ;; zaehle wie oft das suchstring im text buffer vorkommt
  408. (define (text-find-count text d)
  409.   (let ((count 0)
  410.         (old-pos (txt-dot text))
  411.         (found #f)
  412.         (s (dbox-getfield d 2 60)))
  413.     (cond ((> (length s) 0)
  414.            (dbox-setfield d 8 "counting ...")
  415.            (text-dont-update text)
  416.            (set! *text-previous-searchstring* s)
  417.            (while (set! found (txt-findforward text s
  418.                                                *text-casesensitiv-find*))
  419.                   (inc! count)
  420.                   (txt-setdot text (second found)))
  421.            (dbox-setfield d 8 (string-concat count " found"))
  422.            (txt-setdot text old-pos)
  423.            (text-update text)))))
  424.       
  425.       
  426. ;; suche das suchstring im textbuffer in vorwaertsrichtung
  427. (define (text-find-next text d)
  428.   (let ((s (dbox-getfield d 2 60)))
  429.     (cond ((> (length s) 0)
  430.            (set! *text-previous-searchstring* s)
  431.            (set! found (txt-findforward text s *text-casesensitiv-find*))
  432.            (cond (found
  433.                    (txtscrap-setselect text (car found) (second found))
  434.                    (txt-setdot text (second found))
  435.                    (dbox-setfield d 8 "String found"))
  436.                  (else (dbox-setfield d 8 "String not found"))))))) 
  437.                
  438.                  
  439. ;; suche das suchstring im textbuffer in rueckwaertsrichtung 
  440. (define (text-find-previous text d)
  441.   (let ((s (dbox-getfield d 2 60)))
  442.     (cond ((> (length s) 0)
  443.            (set! *text-previous-searchstring* s)
  444.            (set! found (txt-findbackward text s *text-casesensitiv-find*))
  445.            (cond (found
  446.                    (txtscrap-setselect text (car found) (second found))
  447.                    (txt-setdot text (car found))
  448.                    (dbox-setfield d 8 "String found"))
  449.                  (else (dbox-setfield d 8 "String not found"))))
  450.           (else (dbox-setfield d 2 *text-previous-searchstring*)))))           
  451.  
  452.